home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / pp001.zip / PP.PAS < prev    next >
Pascal/Delphi Source File  |  1993-04-22  |  28KB  |  1,161 lines

  1. Program Kiss15;
  2. {$X+}
  3. {
  4.   Who:  Michael Warot
  5.   When: November 12,1989
  6.   What: The beginnings of a language compiler, takes source from
  7.         STDIN, and generates Assembler Source for STDOUT
  8.  
  9.   Based on the article "The Nuts & Bolts of Compiler Construction"
  10.                         By Jack W. Crenshaw
  11.                         Computer Language
  12.                         Volume 6, Number 3  (March 1989)
  13.  
  14.   KISS.PAS is pretty much the same as that given in the article, with
  15.   the appropriate modifications for the MS-DOS environment.
  16.  
  17.   All further versions are based on my assumptions of what should be
  18.   happening inside a compiler. You learn many interesting things when
  19.   you write your own compiler.
  20.  
  21.   Triva: _ is a valid variable name!
  22.  
  23.   Output to assembler file is to eliminate the need for handling
  24.   variable allocation, symbol table handling, and linking.
  25.   This does, however make optimization more difficult.
  26.  
  27. /-Version Number
  28. |
  29. |  Additions & Modifications from previous version....
  30. V ----------------------------------------------------------------------------
  31.  
  32. 2 GetName returns a multi-character name
  33. 2 GetNum  returns a multi-digit number
  34.  
  35. 3 SkipSpace procedure added, handles tabs, cr, lf, and spaces
  36. 3 Match handles a string (for ':=')
  37. 3 Match, GetName, and GetNum all call SkipSpace after doing thier work
  38.  
  39. 4 Statement procedure added to allow for other than assignments
  40. 4 NewLabel  returns a label for jumps, etc
  41. 4 PutLabel  anchors a jump to a particular address
  42. 4 JumpTo    generates code for a jump
  43. 4 IfJumpTo  generates "Jump if <> 0"
  44. 4 IfNotJumpTo generates "Jump if = 0"
  45. 4 While_Loop generates proper code for: while..expression..do..statement
  46. 4 BlockStatement handles begin..statement..[;..statement]..end
  47. 4 Repeat_Loop handles repeat..[statement..;]..until
  48. 4 _Program handles whole program generation
  49. 4 ProgramExit generates DOS exit code
  50.  
  51. 6 Procedure GetToken added
  52.   Handles brace comments
  53.   Handles $12FaC hex constants
  54.   Handles 1243 decimal constants
  55.   Handles 'string constants' and checks for un-terminated string constant
  56. 6 Procedure Match modified to expect a token.
  57.   All routines now use GetToken properly
  58.  
  59. 7 Added simple symbol table
  60.   Added routines to put variables after the end of the code
  61. 7 Added routines to generate prefix and suffix code
  62. 7 Added EMIT to generate some output, for testing, etc.
  63.  
  64. 8 Add FOR x := y TO z DO
  65.   Add WriteLn
  66.   Fix gettoken, so that writeln matches writeln, not write!
  67.   Add Inc_Const, for better code output...
  68.  
  69. 9 Eliminate spurious comments in generated listing
  70.   Put all code generation in GenCode
  71.  
  72. 10 Add variable support, instead of adding variables on the fly.
  73.    Add type support, instead of default to integer
  74.  
  75. 12 Fix bug in FOR, didn't allocate variable for limit correctly...
  76.  
  77. 13 Move input and output from stdin and stdout to file I/O.
  78.  
  79. 14 Add line number to error message, to make life a little easier.
  80.    Fix missing DUP in storage declarations to MASM causeing misallocation
  81.  
  82.    Add support for string expressions....   (NIY)
  83.    Add support for variable types           (NIY)
  84.    Add automatic casting...                 (NIY)
  85.    Fix bug in gettoken that handled '' as a string constant improperly
  86.    Add code to handle (* *) comments
  87.  
  88. 15 Modify to generate OS/2 Full Screen 32 Bit code!
  89. }
  90. Uses
  91.   Swap;
  92. Const
  93.   CR  = ^M;
  94.   LF  = ^J;
  95.   Tab = ^I;
  96.   HexCode   = '0123456789ABCDEF';
  97.  
  98.   MASM      = 'C:\MASM\MASM.EXE';
  99.   LINK      = 'C:\OS2\LINK386.EXE';
  100.  
  101. Type
  102.   Str32     = String[32];
  103.   Token     = (_Unknown,_string_constant,_numeric_Constant,_name,
  104.                _program,_Var,_Begin,_While,_do,_repeat,_Until,
  105.                _Emit,_Write,_WriteLn,
  106.                _period,_comma,
  107.                _plus,_minus,_mul,_div,_lparen,_rparen,_separator,
  108.                _assign,_equal,_greater,_less,_less_eq,_greater_eq,_not_eq,
  109.                _colon,
  110.                _if,_then,_else,_for,_to,
  111.                _end);
  112.  
  113.   ObjCode   = (_Clear,_LoadConst,_LoadVar,_Push,_PopAdd,_PopSub,
  114.                _PopMul,_PopDiv,_Store,_Inc_Const,_PutLabel,
  115.                _JumpTo,_IfJumpTo,_IfNotJumpTo,
  116.                _ProgramInit,_ProgramExit,
  117.                _Logical,_Logical_Not,
  118.                Greater,Less,_PutC,_PutWord,_PutCrLf,_PutString);
  119. Const
  120.   MaxToken  = Ord(_end);
  121.   TokenName : Array[0..MaxToken] of Str32 =
  122.               ('','','','',
  123.                'PROGRAM','VAR','BEGIN','WHILE','DO','REPEAT','UNTIL',
  124.                'EMIT','WRITE','WRITELN',
  125.                '.',',',
  126.                '+','-','*','/','(',')',';',
  127.                ':=','=','>','<','<=','>=','<>',':',
  128.                'IF','THEN','ELSE','FOR','TO',
  129.                'END');
  130.  
  131. Type
  132.   NameStr   = String;
  133.   LabelStr  = String;
  134. Var
  135.   Look           : Char;
  136.   Current_String : String;
  137.   Current_Token  : Token;
  138.   Current_Number : Longint;
  139.  
  140.   Source,Dest    : Text;
  141.   Name           : String;
  142.   LineCount      : Longint;
  143.  
  144. function  numb(i : integer):string;
  145. var
  146.   s : string;
  147. begin
  148.   str(i,s);
  149.   numb := s;
  150. end;
  151.  
  152. Procedure Abort(S : String); Forward;
  153.  
  154. Procedure GetChar;
  155. begin
  156.   if Not Eof(Source) then Read(Source,Look)
  157.                      else Look := '.';
  158.   {                      Abort('Unexpected end of file'); }
  159.   If Look = #13 then Inc(LineCount);
  160. end;
  161.  
  162. procedure SkipSpace;
  163. begin
  164.   While (look in [Cr,Lf,Tab,' ']) AND (Not Eof(Source)) do
  165.     GetChar;
  166. end;
  167.  
  168. Procedure GetToken;
  169. label
  170.   restart,
  171.   done;
  172. var
  173.   i,j : word;
  174.   x   : boolean;
  175.   last: char;
  176. begin
  177. RESTART:
  178.   Current_String := '';
  179.   Current_Token  := _Unknown;
  180.   Current_Number := 0;
  181.   SkipSpace;
  182.   Case Look of
  183.     '{'  : begin
  184.              repeat
  185.                GetChar;
  186.              until Look = '}';
  187.              GetChar;
  188.              Goto Restart;
  189.            end;
  190.  
  191.     '('  : begin
  192.              getchar;
  193.              if look = '*' then
  194.              begin
  195.                getchar;
  196.                repeat
  197.                  last := look;
  198.                  getchar;
  199.                until (last = '*') and (look = ')');
  200.                getchar;
  201.  
  202.                Goto Restart;
  203.              end
  204.              else
  205.                current_token := _lparen;
  206.            end;
  207.  
  208. (*****  Doesn't handle '' as a nul string!
  209.  
  210.     '''' : begin
  211.              getchar;
  212.              repeat
  213.                 repeat
  214.                   current_string := current_string + look;
  215.                   getchar;
  216.                 until (look = '''') or (look = cr);
  217.                 if (look = cr) then abort('String exceeds line');
  218.                 getchar;
  219.              until look <> '''';
  220.              current_token := _string_constant;
  221.            end;
  222. ************)
  223.  
  224.     '''' : begin
  225.              getchar;
  226.              current_string := '';
  227.              x := false;
  228.              repeat
  229.                case look of
  230.                  cr    : abort('String exceeds line');
  231.                  ''''  : begin
  232.                            getchar;
  233.                            if look <> '''' then
  234.                              x := true
  235.                            else
  236.                              current_string := current_string + look;
  237.                          end;
  238.                else
  239.                  current_string := current_string + look;
  240.                  getchar;
  241.                end;
  242.              until x;
  243.              current_token := _string_constant;
  244.            end;
  245.  
  246.     '$'  : begin
  247.              GetChar;
  248.              While (UpCase(Look) in ['0'..'9','A'..'F']) do
  249.              begin
  250.                Current_Number := Current_Number SHL 4 +
  251.                                  Pos(UpCase(Look),HexCode)-1;
  252.                GetChar;
  253.              end;
  254.              Current_Token := _numeric_constant;
  255.            end;
  256.     '0'..'9' : begin
  257.                  while look in ['0'..'9'] do
  258.                  begin
  259.                    Current_Number := Current_Number * 10 +
  260.                                      Pos(Look,HexCode)-1;
  261.                    GetChar;
  262.                  end;
  263.                  current_token := _numeric_constant;
  264.                end;
  265.     '_','A'..'Z',
  266.         'a'..'z'   : begin
  267.                        While UpCase(Look) in ['_','0'..'9',
  268.                                                   'A'..'Z',
  269.                                                   'a'..'z' ] do
  270.                        begin
  271.                          Current_String := Current_String + UpCase(Look);
  272.                          GetChar;
  273.                          for i := 0 to MaxToken do
  274.                            if Current_String = TokenName[i] then
  275.                            begin
  276.                              Current_Token := Token(i);
  277.                           {   goto done; }
  278.                            end;
  279.                        end;
  280.                        If Current_Token = _Unknown then
  281.                          Current_Token := _name;
  282.                      end;
  283.   else
  284.     Current_String := UpCase(Look); GetChar;
  285.     Repeat
  286.       J := 0;
  287.       For i := 0 to MaxToken do
  288.         if (Current_string+UpCase(Look)) = TokenName[i] then
  289.           J := i;
  290.       If J <> 0 then
  291.       begin
  292.         Current_String := Current_String + UpCase(Look);
  293.         GetChar;
  294.       end;
  295.     Until J = 0;
  296.  
  297.     For i := 0 to MaxToken do
  298.       if Current_String = TokenName[i] then
  299.         J := i;
  300.     Current_Token := Token(j);
  301.   end; { Case Look }
  302.  
  303. { If we get here, we have a string that makes no sense! }
  304.  
  305. DONE:
  306. end;
  307.  
  308. (*********************
  309.     Error Reporting
  310.  *********************)
  311.  
  312. procedure Error(s : string);
  313. begin
  314.   WriteLn;
  315.   WriteLn(^G,'(',LineCount+1,') Error: ',s,'.');
  316. end;
  317.  
  318. procedure Abort(S : String);
  319. begin
  320.   Error(S);
  321.   Halt;
  322. end;
  323.  
  324. procedure Expected(s : string);
  325. begin
  326.   Abort(s + ' Expected');
  327. end;
  328.  
  329. (*************************
  330.      Symbol Table Stuff
  331.  *************************)
  332. Const
  333.   _Integer = 0;
  334.   _Byte    = 1;
  335.   _Long    = 2;
  336. Type
  337.   TType    = Record
  338.                Name  : String[32];
  339.                Size  : Word;
  340.              End;
  341.  
  342.   Symbol   = Record
  343.                Name  : String[32];
  344.                Kind  : Integer;
  345.              End;
  346.  
  347. Const
  348.   TypeInteger  : TType = (Name : '_INTEGER'; Size :2);
  349.   TypeByte     : TType = (Name : '_BYTE';    Size :1);
  350.   TypeLong     : TType = (Name : '_LONG';    Size :4);
  351. Var
  352.   SymbolTable  : Array[0..512] of Symbol;
  353.   SymbolCount  : Integer;
  354.  
  355.   TypeTable    : Array[0..512] of TType;
  356.   TypeCount    : Integer;
  357.  
  358.   StringConst  : Array[0..63]  of String;
  359.   StringCount  : Integer;
  360.  
  361. function ToUpper(S : String):String;
  362. begin
  363.   asm
  364.     cld
  365.     lea    si,S
  366.     les    di,@Result
  367.     SEGSS  lodsb
  368.     stosb
  369.     xor    ah,ah
  370.     xchg   ax,cx
  371.     jcxz   @3
  372.   @1:
  373.     SEGSS  lodsb
  374.     cmp    al,'a'
  375.     ja     @2
  376.     cmp    al,'z'
  377.     jb     @2
  378.     sub    al,20H
  379.   @2:
  380.     stosb
  381.     loop   @1
  382.   @3:
  383.   end;
  384. end;
  385.  
  386. function GetName:String;
  387. begin
  388.   If Current_Token = _Name then
  389.     GetName := '_' + ToUpper(Current_String)
  390.   else
  391.     Expected('Name');
  392.   GetToken;
  393. end;
  394.  
  395. function GetNumber:Integer;
  396. begin
  397.   GetNumber := Current_Number;
  398.   GetToken;
  399. end;
  400.  
  401. Procedure AddSymbol(_Name : String; _Kind : Integer);
  402. Begin
  403.   SymbolTable[SymbolCount].Name := _Name;
  404.   SymbolTable[SymbolCount].Kind := _Kind;
  405.   Inc(SymbolCount);
  406. End; { AddSymbol }
  407.  
  408. Function LookSymbol(_Name : String):Integer;
  409. { True if _NAME is in table }
  410. Var
  411.   q,r : Integer;
  412. Begin
  413.   r := -1;
  414.   For q := 0 to SymbolCount-1 do
  415.     If SymbolTable[q].Name = _Name then
  416.       r := q;
  417.   If r <> -1 then
  418.     LookSymbol := SymbolTable[r].Kind
  419.   else
  420.     LookSymbol := -1;
  421. End;
  422.  
  423. Function CheckSymbol(_Name : String): Integer;
  424. Var
  425.   tmp : integer;
  426. Begin
  427.   tmp := LookSymbol(_Name);
  428.   if tmp = -1 then
  429.     Expected('identifier');
  430.   CheckSymbol := tmp;
  431. End;
  432.  
  433. Procedure DumpSymbols;
  434. var
  435.   i : integer;
  436. Begin
  437.   WriteLn(Dest,'; Variable Area');
  438.   for i := 0 to SymbolCount - 1 do
  439.     WriteLn(Dest,SymbolTable[i].Name,TAB,
  440.                  'DB',TAB,
  441.                  TypeTable[SymbolTable[i].Kind].Size,TAB,
  442.                  'DUP (?)');
  443. End;
  444.  
  445. Function LookType(    _Name : String):Integer;
  446. { True if _NAME is in table }
  447. Var
  448.   q,r : Integer;
  449. Begin
  450.   r := -1;
  451.   For q := 0 to TypeCount-1 do
  452.     If TypeTable[q].Name = _Name then
  453.       r := q;
  454.   LookType := r;
  455. End;
  456.  
  457. Procedure CheckType(_Name : String);
  458. Begin
  459.   If (LookType(_Name) = -1) then
  460.     Expected('type');
  461. End;
  462.  
  463. Function DoStringConst(S : String):String;
  464. Begin
  465.   StringConst[StringCount] := S;
  466.   DoStringConst := '_STR'+Numb(StringCount);
  467.   Inc(StringCount);
  468. End;
  469.  
  470. Procedure DumpStrings;
  471. Var
  472.   i : integer;
  473.   s : string;
  474. Begin
  475.   WriteLn(Dest,'; String constants');
  476.   for i := 0 to StringCount-1 do
  477.   begin
  478.     s := StringConst[i];
  479.     WriteLn(Dest,'_STR'+Numb(i),TAB,
  480.                  'DD',TAB,
  481.                  Numb(Length(S)));
  482.     WriteLn(Dest,TAB,'DB',TAB,'''',S,'''');
  483.   end;
  484. End;
  485.  
  486.  
  487. (*************************
  488.       Code Generator
  489.  *************************)
  490. Var
  491.   LabelCount : Word;
  492.  
  493. procedure Emit(s : string);
  494. begin
  495.   Write(Dest,'      ', s);
  496. end;
  497.  
  498. procedure EmitLn(s : string);
  499. begin
  500.   Emit(s);
  501.   WriteLn(Dest);
  502. end;
  503.  
  504. function  NewLabel:LabelStr;
  505. var
  506.   tmp : string;
  507. begin
  508.   Str(LabelCount,tmp); Inc(LabelCount);
  509.   tmp := 'L'+tmp;
  510.   NewLabel := tmp;
  511. end;
  512.  
  513. Function GenCode(c : ObjCode;
  514.                    n : integer;
  515.                    s : string) : integer;
  516. Var
  517.  Tmp : String;
  518.  x,y : integer;
  519. Begin
  520.   Case c of
  521.     _Clear      : EmitLn('XOR   EAX,EAX');
  522.     _LoadConst  : EmitLn('MOV   EAX,'+Numb(N));
  523.     _LoadVar    : begin
  524.                     x := CheckSymbol(s);
  525.                     y := TypeTable[x].Size;
  526.                     Case Y of
  527.                       1 : begin
  528.                             EmitLn('XOR   EAX,EAX');
  529.                             EmitLn('MOV   AL,BYTE PTR['+S+']');
  530.                           end;
  531.                       2 : begin
  532.                             EmitLn('XOR   EAX,EAX');
  533.                             EmitLn('MOV   AX,WORD PTR['+S+']')
  534.                           end;
  535.                       4 : EmitLn('MOV   EAX,DWORD PTR['+S+']');
  536.                     else
  537.                         Abort('Illegal variable size');
  538.                     end;
  539.                   end;
  540.  
  541.     _Push       : EmitLn('PUSH  EAX');
  542.     _PopAdd     : begin
  543.                     EmitLn('POP   EBX');
  544.                     EmitLn('ADD   EAX,EBX');
  545.                   end;
  546.     _PopSub     : begin
  547.                     EmitLn('POP   EBX');
  548.                     EmitLn('SUB   EBX,EAX');
  549.                     EmitLn('MOV   EAX,EBX');
  550.                   end;
  551.     _PopMul     : begin
  552.                     EmitLn('POP   EBX');
  553.                     EmitLn('MUL   EBX');
  554.                   end;
  555.     _PopDiv     : begin
  556.                     EmitLn('MOV   EBX,EAX');
  557.                     EmitLn('XOR   EDX,EDX');
  558.                     EmitLn('POP   EAX');
  559.                     EmitLn('DIV   EBX');
  560.                   end;
  561.     _Store      : begin
  562.                     x := CheckSymbol(s);
  563.                     y := TypeTable[x].Size;
  564.                     Case Y of
  565.                       1 : EmitLn('MOV   BYTE  PTR['+S+'],AL ');
  566.                       2 : EmitLn('MOV   WORD  PTR['+S+'],AX ');
  567.                       4 : EmitLn('MOV   DWORD PTR['+S+'],EAX');
  568.                     else
  569.                       Abort('Illegal variable size');
  570.                     end;
  571.                   end;
  572.     _Inc_Const  : begin
  573.                     if N = 1 then
  574.                       EmitLn('INC   ['+S+']')
  575.                     else
  576.                       EmitLn('ADD   ['+S+'],'+numb(N) );
  577.                   end;
  578.     _PutLabel   : WriteLn(Dest,S+':');
  579.     _JumpTo     : EmitLn('JMP   '+S);
  580.     _IfJumpTo   : Begin
  581.                     Tmp := NewLabel;
  582.                     EmitLn('OR    EAX,EAX');
  583.                     EmitLn('JNZ   '+S);
  584.                   End;
  585.  
  586.     _IfNotJumpTo: Begin
  587.                     Tmp := NewLabel;
  588.                     EmitLn('OR    EAX,EAX');   { Avoid 128 byte jump bounds }
  589.                     EmitLn('JZ    '+S);
  590.                   End;
  591.  
  592.     _ProgramInit: Begin
  593.                     WriteLn(Dest,'      .386                        ');
  594.                     WriteLn(Dest,'      .model   flat,syscall,os_os2');
  595.                     WriteLn(Dest,'      .code                       ');
  596.                     WriteLn(Dest,'Main:                             ');
  597.                   End;
  598.  
  599.     _ProgramExit: Begin
  600.                     EmitLn('CALL  _EXIT');
  601.                   End;
  602.  
  603.     _Logical    : Begin
  604.                     EmitLn('NEG   EAX');         { AX <> 0 ---> Carry  }
  605.                     EmitLn('MOV   EAX,0');       {       0 ---> AX     }
  606.                     EmitLn('SBC   EAX,EAX');     { Carry  ----> ALL AX }
  607.                   End;
  608.  
  609.     _Logical_Not: Begin
  610.                     EmitLn('NEG   EAX');         { AX <> 0 ---> Carry  }
  611.                     EmitLn('MOV   EAX,-1');      {      -1 ---> AX     }
  612.                     EmitLn('ADC   EAX,0');       { Not Carry -> ALL AX }
  613.                   End;
  614.  
  615.     Greater     : Begin
  616.                     EmitLn('POP   EBX');
  617.                     EmitLn('SUB   EAX,EBX');
  618.                     EmitLn('MOV   EAX,0' );
  619.                     EmitLn('SBB   EAX,0' );
  620.                   end;
  621.  
  622.     Less        : Begin
  623.                     EmitLn('POP   EBX');
  624.                     EmitLn('SUB   EBX,EAX');
  625.                     EmitLn('MOV   EAX,0' );
  626.                     EmitLn('SBB   EAX,0' );
  627.                   end;
  628.  
  629.     _PutC       : EmitLn('CALL  PUTC');
  630.  
  631.     _PutWord    : EmitLn('CALL  WriteEAX');
  632.  
  633.     _PutCrLf    : EmitLn('CALL  DoCR');
  634.  
  635.     _PutString  : Begin
  636.                     EmitLn('LEA   EDX,'+S);
  637.                     EmitLn('CALL  WriteStr');
  638.                   End;
  639.  
  640.   else
  641.     Abort('Unknown ObjCode');
  642.   end;
  643. End;
  644.  
  645. (**********************
  646.     Parsing Routines
  647.  **********************)
  648.  
  649. function IsCompareOp(x : token): boolean;
  650. begin
  651.   IsCompareOp := x in [_equal.._not_eq];
  652. end;
  653.  
  654. function IsAddOp(x : token): boolean;
  655. begin
  656.   IsAddOp := x in [_plus,_minus];
  657. end;
  658.  
  659. function IsMulOp(x : token): boolean;
  660. begin
  661.   IsMulOp := x in [_mul,_div];
  662. end;
  663.  
  664. procedure Match(x : Token);
  665. begin
  666.   If Current_Token <> X then
  667.   begin
  668.     If Ord(X) <= MaxToken then
  669.       Expected(TokenName[ord(x)])
  670.     else
  671.       Abort('Unknown Token expected, compiler error!');
  672.   end
  673.   else
  674.     GetToken;
  675. end;
  676.  
  677. (*************************
  678.     Expression Parser
  679.  *************************)
  680.  
  681. function  Expression:integer; Forward;
  682. function  Value:integer;
  683. var
  684.   kind : integer;
  685. begin
  686.   kind := -1;
  687.   If Current_Token = _lparen then
  688.   begin
  689.     Match(_lparen);
  690.     kind := Expression;
  691.     Match(_rparen);
  692.   end
  693.   else
  694.   begin
  695.     If Current_Token = _name then
  696.       Kind := GenCode(_LoadVar,0,GetName)
  697.     else
  698.       If Current_Token = _numeric_constant then
  699.         Kind := GenCode(_LoadConst,GetNumber,'')
  700.       else
  701.         Error('Error in expression');
  702.   end;
  703. end;
  704.  
  705. procedure Factor;
  706. var
  707.   tmp : token;
  708.   kind : integer;
  709. begin
  710.   kind := Value;
  711.   while IsCompareOp(Current_Token) do
  712.   begin
  713.     GenCode(_Push,kind,'');
  714.     tmp := Current_Token;
  715.     Match(tmp);
  716.     Value;
  717.  
  718.     case tmp of
  719.       _equal       : begin
  720.                        GenCode(_PopSub,     kind,'');
  721.                        GenCode(_Logical,    kind,'');
  722.                      end;
  723.       _not_eq      : begin
  724.                        GenCode(_PopSub,     kind,'');
  725.                        GenCode(_Logical_Not,kind,'');
  726.                      end;
  727.       _greater     : GenCode(Greater,     kind,'');
  728.       _less        : GenCode(Less,        kind,'');
  729.       _greater_eq  : begin
  730.                        GenCode(Less,        kind,'');
  731.                        GenCode(_Logical_Not,kind,'');
  732.                      end;
  733.       _less_eq     : begin
  734.                        GenCode(Greater,     kind,'');
  735.                        GenCode(_Logical_Not,kind,'');
  736.                      end;
  737.     end;
  738.   end;
  739. end;
  740.  
  741. procedure Multiply;
  742. begin
  743.   Match(_mul);
  744.   Factor;
  745.   GenCode(_PopMul,0,'');
  746. end;
  747.  
  748. procedure Divide;
  749. begin
  750.   Match(_div);
  751.   Factor;
  752.   GenCode(_PopDiv,0,'');
  753. end;
  754.  
  755. procedure Term;
  756. begin
  757.   Factor;
  758.   while IsMulOp(Current_Token) do
  759.   begin
  760.     GenCode(_Push,0,'');
  761.     case Current_Token of
  762.       _mul : Multiply;
  763.       _div : Divide;
  764.     end;
  765.   end;
  766. end;
  767.  
  768. procedure Add;
  769. begin
  770.   Match(_plus);
  771.   Term;
  772.   GenCode(_PopAdd,0,'');
  773. end;
  774.  
  775. procedure Subtract;
  776. begin
  777.   Match(_minus);
  778.   Term;
  779.   GenCode(_PopSub,0,'');
  780. end;
  781.  
  782. function Expression : integer;     { returns expression type }
  783. var
  784.   kind : integer;
  785. begin
  786.   kind := -1;
  787.   If IsAddOp(Current_Token) then GenCode(_Clear,0,'')
  788.                             else Term;
  789.   while IsAddOp(Current_Token) do
  790.   begin
  791.     GenCode(_Push,0,'');
  792.     case Current_Token of
  793.       _plus   : Add;
  794.       _minus  : Subtract;
  795.     end;
  796.   end;
  797.   Expression := kind;
  798. end;
  799.  
  800. (*************************
  801.      Statement Parser
  802.  *************************)
  803.  
  804. procedure Statement; Forward;
  805.  
  806. procedure Assignment;
  807. var
  808.   tmp : string;
  809. begin
  810.   Tmp := GetName;
  811.   Match(_assign);
  812.   Expression;
  813.   GenCode(_Store,0,Tmp);
  814. end;
  815.  
  816. procedure While_Loop;
  817. var
  818.   TestLabel,
  819.   DoneLabel : LabelStr;
  820. begin
  821.   Match(_While);
  822.  
  823.   TestLabel := NewLabel;
  824.   DoneLabel := NewLabel;
  825.  
  826.   GenCode(_PutLabel,0,TestLabel);
  827.   Expression;
  828.   GenCode(_IfNotJumpTo,0,DoneLabel);
  829.   Match(_do);
  830.  
  831.   Statement;
  832.   GenCode(_JumpTo,0,TestLabel);
  833.  
  834.   GenCode(_PutLabel,0,DoneLabel);
  835. end;
  836.  
  837. procedure For_Loop;
  838. var
  839.   DoneLabel,
  840.   TestLabel   : LabelStr;
  841.   Index,Limit : String;
  842. begin
  843.   Match(_For);
  844.   TestLabel  := NewLabel;
  845.   DoneLabel  := NewLabel;
  846.  
  847.   Index := GetName;
  848.   Limit := 'Lim'+Index;
  849.   AddSymbol(Limit,_Long);
  850.   Match(_assign);
  851.   Expression;  GenCode(_Store,0,Index);
  852.   Match(_to);
  853.   Expression;  GenCode(_Store,0,Limit);
  854.  
  855.   GenCode(_PutLabel,0,TestLabel);
  856.   Match(_do);
  857.   GenCode(_LoadVar,0,Index);
  858.   GenCode(_Push,0,'');
  859.   GenCode(_LoadVar,0,Limit);
  860.   GenCode(Greater,0,'');
  861.   GenCode(_IfJumpTo,0,DoneLabel);
  862.  
  863.   Statement;
  864.   GenCode(_Inc_Const,1,Index);
  865.   GenCode(_JumpTo,0,TestLabel);
  866.  
  867.   GenCode(_PutLabel,0,DoneLabel);
  868. end;
  869.  
  870. procedure If_Then_Else;
  871. var
  872.   ElseLabel,
  873.   DoneLabel  : LabelStr;
  874. begin
  875.   Match(_If);
  876.  
  877.   ElseLabel := NewLabel;
  878.   DoneLabel := NewLabel;
  879.  
  880.   Expression;
  881.   Match(_then);
  882.   GenCode(_IfNotJumpTo,0,ElseLabel);
  883.  
  884.   Statement;
  885.  
  886.   If Current_Token = _Separator then
  887.     GenCode(_PutLabel,0,ElseLabel)
  888.   else
  889.   begin
  890.     Match(_else);
  891.     GenCode(_JumpTo,0,DoneLabel);
  892.     GenCode(_PutLabel,0,ElseLabel);
  893.     Statement;
  894.   end;
  895.  
  896.   GenCode(_PutLabel,0,DoneLabel);
  897. end;
  898.  
  899. procedure BlockStatement;
  900. var
  901.   tmp : NameStr;
  902. begin
  903.   Match(_Begin);
  904.  
  905.   while Current_Token <> _End do
  906.   begin
  907.     If Current_Token = _Separator then
  908.       GetToken
  909.     else
  910.       Statement;
  911.   end;
  912.   Match(_End);
  913. end;
  914.  
  915. procedure VarStatement(var kind : integer);
  916. var
  917.   Name : NameStr;
  918. begin
  919.   Name := GetName;
  920.   If (Current_Token = _Comma) then
  921.   begin
  922.     Match(_Comma);
  923.     VarStatement(kind);
  924.   end
  925.   else
  926.   begin
  927.     Match(_Colon);
  928.     kind := LookType(GetName);
  929.     If Kind = -1 then Expected('TYPE');
  930.   end;
  931.   AddSymbol(Name,kind);
  932. end;
  933.  
  934. procedure VarBlock;
  935. var
  936.   tmp  : NameStr;
  937.   kind : integer;
  938. begin
  939.   Match(_Var);
  940.   while (Current_Token = _Name) do
  941.   begin
  942.     VarStatement(kind);
  943.     Match(_separator);
  944.   end;
  945. end;
  946.  
  947. procedure Repeat_Loop;
  948. var
  949.   tmp   : NameStr;
  950.   Start : LabelStr;
  951. begin
  952.   Match(_Repeat);
  953.  
  954.   Start := NewLabel;
  955.   GenCode(_PutLabel,0,Start);
  956.  
  957.   repeat
  958.     If Current_Token <> _Until then
  959.     begin
  960.       Statement;
  961.       Match(_separator);
  962.     end;
  963.   until Current_Token = _Until;
  964.  
  965.   Match(_Until);
  966.  
  967.   Expression;
  968.   GenCode(_IfNotJumpTo,0,Start);
  969. end;
  970.  
  971. Procedure Write_Work;
  972. Var
  973.   sx : string;
  974. Begin
  975.   If Current_Token = _Lparen then      { Fix for WriteLn; (No Operands) }
  976.   begin
  977.     Match(_lparen);
  978.     Repeat
  979.       if Current_Token = _String_Constant then
  980.       begin
  981.         sx := DoStringConst(Current_String);
  982.         Match(_String_Constant);
  983.         GenCode(_PutString,0,sx);
  984.       end
  985.       else
  986.       begin
  987.         Expression;
  988.         GenCode(_PutWord,0,'');
  989.       end;
  990.       If Current_Token <> _Rparen then
  991.         Match(_comma);
  992.     Until Current_Token = _Rparen;
  993.     Match(_Rparen);
  994.   end;
  995. End;
  996.  
  997. procedure Statement;
  998. begin
  999.   Case Current_Token of
  1000.     _while  : while_Loop;
  1001.     _repeat : repeat_loop;
  1002.     _for    : for_loop;
  1003.     _if     : if_then_else;
  1004.     _begin  : BlockStatement;
  1005.     _emit   : begin
  1006.                 Match(_emit);
  1007.                 Match(_lparen);
  1008.                 Repeat
  1009.                   Expression;
  1010.                   GenCode(_PutC,0,'');
  1011.                   If Current_Token <> _Rparen then
  1012.                     Match(_comma);
  1013.                 Until Current_Token = _Rparen;
  1014.                 Match(_Rparen);
  1015.               end;
  1016.     _Write  : begin
  1017.                 Match(_Write);
  1018.                 Write_Work;
  1019.               end;
  1020.     _WriteLn: begin
  1021.                 Match(_WriteLn);
  1022.                 Write_Work;
  1023.                 GenCode(_PutCrLf,0,'');
  1024.               end;
  1025.   else
  1026.     Assignment;
  1027.   end;
  1028. end;
  1029.  
  1030. (****************************
  1031.          Program Parser
  1032.  ****************************)
  1033. var
  1034.   ProgramName : NameStr;
  1035.  
  1036. procedure _Program_;
  1037. var
  1038.   tmp : NameStr;
  1039.   lib : text;
  1040.   buf : string;
  1041.   done : boolean;
  1042. begin
  1043.   If Current_Token = _Program then
  1044.   begin
  1045.     Match(_Program);
  1046.     ProgramName := GetName;
  1047.     Match(_separator);
  1048.   end;
  1049.  
  1050.   GenCode(_ProgramInit,0,ProgramName);
  1051.  
  1052.   Done := False;
  1053.   begin
  1054.     Case Current_Token of
  1055.       _Var  : VarBlock;
  1056.     else
  1057.       Done := True;
  1058.     End;
  1059.   end;
  1060.  
  1061.   BlockStatement;
  1062.   GenCode(_ProgramExit,0,'');
  1063.  
  1064.   WriteLn(Dest,'; ***** Library Code ***** ');
  1065.  
  1066.   Assign(Lib,'LIB.ASM');
  1067. {$I-}  Reset(Lib); {$I+}
  1068.   If IOresult = 0 then
  1069.   begin
  1070.     while not eof(lib) do
  1071.     begin
  1072.       readln(lib,buf);
  1073.       writeln(Dest,buf);
  1074.     end;
  1075.     close(lib);
  1076.   end;
  1077.  
  1078.   WriteLn(Dest,'; ***** Library Ends *****');
  1079.   DumpSymbols;
  1080.   DumpStrings;
  1081.   EmitLn('db      100 dup(0)');
  1082.   EmitLn('end     main   ');
  1083. end;
  1084.  
  1085. (**************************
  1086.         Main Program
  1087.  **************************)
  1088.  
  1089. procedure Init;
  1090. begin
  1091.   LineCount   := 0;
  1092.   LabelCount  := 0;
  1093.   SymbolCount := 0;
  1094.   StringCount := 0;
  1095.  
  1096.   TypeTable[0] := TypeInteger;
  1097.   TypeTable[1] := TypeByte;
  1098.   TypeTable[2] := TypeLong;
  1099.   TypeCount    := 3;
  1100.  
  1101.   ProgramName := 'NONAME';
  1102.   GetChar;
  1103.   GetToken;
  1104. end;
  1105.  
  1106. procedure usage;
  1107. begin
  1108.   WriteLn('Power Pascal -- Copyright(C) 1993, Blue Star Systems, all rights reserved');
  1109.   WriteLn;
  1110.   WriteLn('Usage : PP filename  (.PRG assumed) ');
  1111.   Halt(0);
  1112. end;
  1113.  
  1114. Var
  1115.   Err : Byte;
  1116.   F   : file;
  1117. Begin
  1118.   If ParamCount = 0 then usage;
  1119.   Name := ParamStr(1);
  1120.   If Pos('?',name) <> 0 then Usage;
  1121.  
  1122.   Assign(Source,Name+'.PRG');
  1123. {$I-} Reset(Source); {$I+}
  1124.   If IOresult <> 0 then
  1125.   begin
  1126.     WriteLn('Error opening input file ',Name,'.prg');
  1127.     Halt(1);
  1128.   end;
  1129.  
  1130.   Assign(Dest,Name+'.ASM');
  1131. {$I-} ReWrite(Dest); {$I+}
  1132.   If IOresult <> 0 then
  1133.   begin
  1134.     WriteLn('Error opening output file, ',Name,'.asm');
  1135.     Halt(2);
  1136.   end;
  1137.  
  1138.   Init;
  1139.   _Program_;
  1140.  
  1141.   Close(Source);
  1142.   Close(Dest);
  1143.   WriteLn('Total of ',LineCount,' Lines processed');
  1144.  
  1145.   Swap.SetMemTop(HeapPtr);
  1146.                   Err := ExecPrg(MASM+' '+Name+';');
  1147.   If Err = 0 then Err := ExecPrg(LINK+' '+Name+','+Name+',NUL,C:\OS2\DOSCALLS,PP');
  1148.  
  1149.   Swap.SetMemTop(HeapEnd);
  1150.  
  1151.   if err = 0 then
  1152.   begin
  1153.     assign(f,Name+'.OBJ');
  1154.     {$I-} reset(f,1); {$I+}
  1155.     if ioresult = 0 then
  1156.     begin
  1157.       close(f);
  1158.       erase(f);
  1159.     end;
  1160.   end;
  1161. End.